gganatogram’s data experiment

https://github.com/jespermaag/gganatogram

The data isn’t stored w/ sf format which the ggregions process requires.. Can’t seem to figure how it works in the original api, but not well when translated…

library(tidyverse)
library(gganatogram)



gganatogram::mmFemale_list |> 
  bind_rows() |>
  remove_missing() |>
  ggplot() + 
  aes(x, -y, group = group, color = id) + 
  geom_polygon(show.legend = F) + 
  coord_equal()

to_sf_routine <- function(data){
  
  data |>
  mutate(y = -y) |>
  sf::st_as_sf(coords = c("x", "y"), agr = "constant") |>
  group_by(id, group) |>
  summarize(do_union = F) |> 
  ungroup() |> 
  group_by(id, group) |>
  summarise() |>
  mutate(geometry = geometry |> sf::st_cast("POLYGON")) |> 
  mutate(geometry = geometry |> sf::st_cast("MULTIPOLYGON")) |> 
  ungroup() 
  
}

mm_female_sf <- gganatogram::mmFemale_list |> 
  bind_rows() |>
  # filter(x != 0, y != 0, y < -2) |>
  remove_missing() |>
  to_sf_routine() |> 
  rename(organ = id)




mm_female_sf |> 
  ggplot()  + 
  geom_sf(aes(geometry = geometry)) + 
  coord_sf()

# compare
ggseg::aseg$data$geometry
## Geometry set for 29 features 
## Geometry type: MULTIPOLYGON
## Dimension:     XY
## Bounding box:  xmin: -0.5 ymin: 0 xmax: 7.061358 ymax: 3.203063
## CRS:           NA
## First 5 geometries:
geom_organ <- ggregions::write_geom_region_locale(mm_female_sf)
stamp_organ <- ggregions::write_stamp_region_locale(mm_female_sf)

mm_female_sf$organ |> sample(20)
##  [1] "peripheral_nervous_system" "peripheral_nervous_system"
##  [3] "peripheral_nervous_system" "peripheral_nervous_system"
##  [5] "adrenal_gland"             "lymph_node"               
##  [7] "UBERON_0000947"            "femur"                    
##  [9] "peripheral_nervous_system" "UBERON_0000947"           
## [11] "peripheral_nervous_system" "reproductive_system"      
## [13] "UBERON_0000947"            "peripheral_nervous_system"
## [15] "peripheral_nervous_system" "peripheral_nervous_system"
## [17] "UBERON_0000947"            "peripheral_nervous_system"
## [19] "peripheral_nervous_system" "peripheral_nervous_system"
ggplot() + 
  stamp_organ() + 
  stamp_organ(keep = "aorta", fill = "darkred") +
  stamp_organ(keep = "brain", fill = "darkseagreen") + 
  stamp_organ(keep = "blood_vessel", fill = "orange")

original mouse gganatogram api

It looks great, but maybe the hard-ish thing is navigating it?

# original api
gganatogram(data = mmFemale_key, 
            outline = T, 
            fillOutline='#440154FF', 
            organism = 'mouse', 
            sex='female', 
            fill="value")  + 
  theme_void()   +  
  scale_fill_viridis_c() +
  coord_equal()

cell_sf <- gganatogram::cell_list[[1]] |> 
  bind_rows() |>
  # filter(x != 0, y != 0, y < -2) |>
  remove_missing() |>
  to_sf_routine() |> 
  rename(organelle = id)


cell_sf |> 
  ggplot()  + 
  geom_sf(aes(geometry = geometry), alpha = .2) + 
  coord_sf()

geom_organelle <- ggregions::write_geom_region_locale(cell_sf)
stamp_organelle <- ggregions::write_stamp_region_locale(cell_sf)

cell_sf
## Simple feature collection with 1088 features and 2 fields
## Geometry type: MULTIPOLYGON
## Dimension:     XY
## Bounding box:  xmin: 5.4 ymin: -483.4 xmax: 606.7 ymax: -8.4
## CRS:           NA
## # A tibble: 1,088 × 3
##    organelle       group                                                geometry
##    <chr>           <chr>                                          <MULTIPOLYGON>
##  1 actin_filaments 6_10  (((43.4 -268.8, 52.5 -250.1, 62.4 -231.9, 74.4 -214.6,…
##  2 actin_filaments 6_11  (((111 -398.1, 113.7 -400.7, 116.4 -403.2, 96.6 -396.2…
##  3 actin_filaments 6_12  (((112.1 -396.9, 112.6 -397.1, 113.2 -397.3, 121 -400.…
##  4 actin_filaments 6_13  (((170.7 -422.4, 175.3 -423.8, 179.9 -425.2, 184.8 -42…
##  5 actin_filaments 6_14  (((197.2 -430.3, 203.4 -432.1, 209.7 -433.9, 206.5 -43…
##  6 actin_filaments 6_15  (((554.9 -230.1, 554.3 -238.9, 553.9 -247.6, 537.5 -17…
##  7 actin_filaments 6_16  (((554.6 -192.2, 556.1 -196.3, 557.6 -200.4, 557.1 -20…
##  8 actin_filaments 6_17  (((557.9 -245.2, 559.4 -261.7, 560.9 -278.7, 559 -269.…
##  9 actin_filaments 6_18  (((523 -91.4, 531 -97, 537.9 -102.8, 543.2 -128.5, 547…
## 10 actin_filaments 6_19  (((512.7 -82.2, 512 -80.5, 511.3 -78.8, 519.4 -82.2, 5…
## # ℹ 1,078 more rows
ggplot() + 
  stamp_organelle(alpha = .2) + 
  stamp_organelle(keep = "actin_filaments", fill = "orange", alpha = .1) +
  stamp_organelle(keep = "endoplasmic_reticulum", fill = "darkred") 

Trying human anatomy with same routing

length(gganatogram::hgFemale_list)
## [1] 204
# fix so that all data frames can be combined with bind_rows
# the groups are numeric and character so using bind_rows fails
female_sf <- gganatogram::hgFemale_list[c(1:156, 180:195)] |> # return to this!!
  bind_rows() |>
  remove_missing() |>
  to_sf_routine() 
  
stamp_organ <- ggregions::write_stamp_region_locale(female_sf)

ggplot() + 
  stamp_organ(alpha = .2) + 
  stamp_organ(keep = "lung", 
              fill = "plum3") + 
  stamp_organ(keep = "stomach",
              fill = "cornsilk") + 
  stamp_organ(keep = "heart", 
              fill = "coral") + 
  stamp_organ(keep = "brain", 
              fill = "pink3")

male_sf <- gganatogram::hgMale_list[2:155] |>  
  bind_rows() |>
  # filter(x != 0, y != 0, y < -2) |>
  remove_missing() |>
  to_sf_routine() 

ggplot(female_sf) + 
  aes(geometry = geometry) +
  geom_sf(alpha = .2)

ggplot(male_sf) + 
  aes(geometry = geometry) +
  geom_sf(alpha = .2)

teethr’s data experiment

https://github.com/bbartholdy/teethr

library(tidyverse)
library(teethr)
teeth_ref_data <- dental_arcade_mapping |> 
  as_tibble() |> 
  left_join(tooth_notation |> 
  select(tooth = text, fdi = FDI, standard = standards) 
  )
head(teeth_ref_data)  # are there other ids?  like just number of tooth?
## # A tibble: 6 × 4
##   tooth                                                  geometry fdi   standard
##   <chr>                                                 <POLYGON> <chr> <chr>   
## 1 URM2  ((65.18537 293.3849, 65.71057 295.1088, 66.38935 296.496… 17    2       
## 2 URM1  ((74.4591 325.7847, 75.55431 326.5688, 76.88258 327.0586… 16    3       
## 3 URP2  ((76.59484 342.573, 77.43558 343.7596, 78.59217 344.6295… 15    4       
## 4 URP1  ((86.86233 359.6018, 86.86725 360.529, 87.02025 360.8659… 14    5       
## 5 URC1  ((101.1985 370.3966, 101.3456 371.2152, 101.6861 371.999… 13    6       
## 6 URI2  ((123.4955 387.3634, 123.4955 387.3634, 124.5163 387.779… 12    7
library(ggregions)
geom_tooth <- ggregions::write_geom_region_locale(teeth_ref_data)
geom_tooth_text <- write_geom_region_text_locale(teeth_ref_data)
stamp_tooth <- write_stamp_region_locale(teeth_ref_data)
stamp_tooth_text <- write_stamp_region_text_locale(teeth_ref_data)



ggplot() + 
  stamp_tooth()

last_plot() + 
  stamp_tooth_text(size = 2)

ggplot() + 
  stamp_tooth() + 
  stamp_tooth_text(size = 2,
                   aes(label = after_stat(fdi)))

ggplot() + 
  stamp_tooth() + 
  stamp_tooth_text(size = 2,
                   aes(label = after_stat(standard)))

caries_ratios <- mb11_caries %>% 
  dental_longer(-id) %>%
  dental_join() %>% 
  count_caries(caries = score, no_lesion = "none") %>% # convert location to lesion count
  group_by(tooth) %>% 
  dental_ratio(count = caries_count) %>%
  dental_recode(tooth, "FDI", "text") 

head(caries_ratios)
## # A tibble: 6 × 4
##   tooth     n count  ratio
##   <chr> <int> <dbl>  <dbl>
## 1 URI1     35     4 0.114 
## 2 URI2     31     4 0.129 
## 3 URC1     35     7 0.2   
## 4 URP1     34     3 0.0882
## 5 URP2     23     5 0.217 
## 6 URM1     32     7 0.219
caries_ratios |> 
  ggplot() + 
  stamp_tooth() + 
  aes(tooth = tooth, 
      fill = ratio) + 
  geom_tooth()

last_plot() + 
  geom_tooth(keep = c("LLM1", "URM3")) |> 
    ggfx::with_outer_glow("red") + 
  geom_tooth_text(keep = c("LLM1", "URM3"),
                  label = "😬",
                  hjust = -0.5) 

aseg X data

library(ggseg)

coronal_ref_data <- ggseg::aseg$data |> 
  filter(side == "coronal") |>     # just look at coronal for the nuttiness.
  group_by(region) |> 
  summarise(geometry = sf::st_combine(geometry)) |> 
  select(region = region, everything())
  
coronal_ref_data |> pull(region)
## [1] "amygdala"          "caudate"           "hippocampus"      
## [4] "lateral ventricle" "pallidum"          "putamen"          
## [7] "thalamus proper"   "ventral DC"        NA
library(ggregions)
geom_region <- write_geom_region_locale(ref_data = coronal_ref_data)
stamp_region <- write_stamp_region_locale(ref_data = coronal_ref_data)
geom_region_text <- write_geom_region_text_locale(ref_data = coronal_ref_data)
stamp_region_text <- write_stamp_region_text_locale(ref_data = coronal_ref_data)


ggplot() + 
  stamp_region() + 
  stamp_region(keep = "hippocampus", fill = "blue")

ggplot() + 
  stamp_region() + 
  stamp_region_text(check_overlap = T)

tribble(~activity, ~segment,
       .2, "hippocampus",
       .5, "amygdala",
       .7, "thalamus proper") |>
ggplot() + 
  stamp_region() + 
  aes(region = segment,
      fill = activity) + 
  geom_region()